home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 004 / pclisp.arc / EXTFUNC.L next >
Encoding:
Text File  |  1986-02-23  |  3.9 KB  |  120 lines
  1. ; EXTFUNC.L                             
  2. ; ~~~~~~~~~                             
  3. ;     A small library of functions to help fill in the gap between PC and      
  4. ; Franz Lisp. These functions are for learning purposes only are not very
  5. ; effectient or very robust. Also included is a set of turtle graphics
  6. ; commands that will work on just about any MS-DOS machine via the BIOS.  
  7. ;    
  8. ;        Peter Ashwood-Smith
  9.  
  10. (defun member(x y)(cond((null y)nil)((equal x(car y))y)(t(member x(cdr y]  
  11. (defun memq(x y)(cond((null y) nil)((eq x(car y))y)(t(memq x(cdr y]  
  12. (defun tailp(l1 l2)(cond ((null l2) nil)((eq l1 l2) l1)(t(tailp l1(cdr l2]  
  13. (defun arrayp(x) nil)        
  14. (defun bcdp(x) nil)        
  15. (defun bigp(x) nil)        
  16. (defun dtpr(x) (and(listp x)(atom (cdr x)]       
  17. (defun fixp(n) nil)
  18. (defun hunkp(n) nil)
  19. (defun litatom(n) (and(atom n)(not(floatp n]   
  20. (defun numbp(n) (floatp n))        
  21. (defun numberp(n) (floatp n))
  22. (defun purep(n)(or(eq n t)(eq n nil)(eq n 'lambda)(eq n 'nlambda)]  
  23. (defun stringp(n) nil)                    
  24. (defun symbolp(n) (litatom n))            
  25. (defun valuep(n) nil)
  26. (defun vectorp(n) nil)
  27. (defun typep(n)(type n))
  28. (defun eqstr(a b)(equal a b))
  29. (defun neq(a b)(not(eq a b)))
  30. (defun nequal(a b)(not(equal a b)))
  31. (defun append1(a b)(append a (list b)))
  32. (defun copy(a)(reverse(reverse a)))        
  33. (defun ncons(a)(cons a nil))
  34. (defun xcons(a b)(cons b a))
  35. (defun last(l)(nth (- (length l) 1) l))
  36. (defun nthcdr(n l)(cond((< n 0)(cons nil l))((= n 0)l)(t(nthcdr (- n 1)(cdr l] 
  37. (defun nthelem(n l) (nth (- n 1) l))
  38. (defun add fexpr(l)(eval(cons '+ l]             
  39. (defun add1(n)(+ 1 n))
  40. (defun diff fexpr(l)(eval(cons '- l]
  41. (defun difference fexpr(l)(eval(cons '- l]
  42. (defun minus(n)(- 0 n))
  43. (defun product fexpr(l)(eval(cons '* l]
  44. (defun times fexpr(l)(eval(cons '* l] 
  45. (defun quotient fexpr(l)(eval(cons '/ l]
  46. (defun sub1(n)(- n 1))
  47. (defun evenp(n)(= (mod n 2) 0))
  48. (defun minusp(n)(< n 0))
  49. (defun oddp(n)(= (mod n 2) 1))
  50. (defun onep(n)(= 1 n))
  51. (defun plusp(n)(> n 0))
  52. (defun zerop(n)(= n 0))
  53. (defun infile(f)(fileopen f 'r)) 
  54. (defun character-index(a c)(prog(n)(setq n 1 a(explode a))(cond((floatp c)(setq c(ascii c))))nxt:(cond((null a)(return nil)))(cond((eq(car a)c)(return n)))(setq n(+ n 1)a(cdr a))(go nxt:]  
  55.     
  56. ; 
  57. ; Some simple Turtle Graphics Routines to demonstrate PC-LISP. Remember that
  58. ; the graphics commands go though the BIOS so they are portable but slow.
  59. ;                     
  60.  
  61. (defun TurtleGraphicsUp()   (#scrmde# 6) (#scrsap# 0) (TurtleCenter))    
  62. (defun TurtleGraphicsDown() (#scrmde# 2))
  63. (defun TurtleCenter()       (setq Lastx 100 Lasty 100 Heading 1.570796372))
  64. (defun TurtleRight(n)       (setq Heading (+ Heading (* n 0.01745329))))
  65. (defun TurtleLeft(n)        (setq Heading (- Heading (* n 0.01745329))))
  66.  
  67. (defun TurtleForward(n) 
  68.       (setq Newx(+ Lastx(*(cos Heading)n))Newy(+ Lasty(*(sin Heading)n)))
  69.       (#scrline#(* Lastx 3.2) Lasty (* Newx 3.2) Newy 1)
  70.       (setq Lastx Newx Lasty Newy)
  71. )
  72.  
  73. ;
  74. ; end of Turtle Graphics primitives, start of Graphics demonstration code
  75. ; you can cut this out if you like and leave the Turtle primitives intact.
  76. ;
  77.  
  78. (defun Line_T(n)    
  79.     (TurtleForward n) (TurtleRight 180)
  80.     (TurtleForward (/ n 4))    
  81. )
  82.     
  83. (defun Square(n)
  84.     (TurtleForward n)  (TurtleRight 90)    
  85.     (TurtleForward n)  (TurtleRight 90)    
  86.     (TurtleForward n)  (TurtleRight 90)    
  87.     (TurtleForward n)            
  88. )
  89.  
  90. (defun Triangle(n)
  91.     (TurtleForward n)  (TurtleRight 120)
  92.     (TurtleForward n)  (TurtleRight 120)
  93.     (TurtleForward n)
  94. )
  95.  
  96. (defun Make(ObjectFunc Size times skew)    
  97.       (prog()       
  98.        TOP:(cond ((= times 0) (return)))
  99.        (ObjectFunc Size) 
  100.        (TurtleRight skew)
  101.        (setq times (- times 1))
  102.        (go TOP:)    
  103.        )
  104. )
  105.  
  106. (defun GraphicsDemo()
  107.        (TurtleGraphicsUp) 
  108.        (Make Square 40 18 5) (Make Square 60 18 5)
  109.        (gc)                            ; idle work
  110.        (TurtleGraphicsUp) 
  111.        (Make Triangle 40 18 5) (Make Triangle 60 18 5)
  112.        (gc)                            ; idle work
  113.        (TurtleGraphicsUp) 
  114.        (Make Line_T 80 50 10)
  115.        (gc)                            ; idle work
  116.        (TurtleGraphicsDown)
  117. )
  118.  
  119.  
  120.